{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE RankNTypes                 #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Text.ZParse.SedParser
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Parsing and stream editing. Two continuation parser 
-- combinators plus output trace.
-- 
--------------------------------------------------------------------------------

module Text.ZParse.SedParser
  (

    module Text.ZParse.Combinators      -- export
  , Parser


  , Result(..)
  , ParseError

  , runParser
  , evalParser
  , parseFromFile

  , both
  , censor
  , tell
  , apply
  , failure
  , throwError
  , (<?>)
  , lookahead
  , peek
  , eof
  , satisfy
  , oneOf
  , noneOf
  , genReplace
  , replaceChar

  -- * Char parsers
  , char
  , string
  , anyChar
  , upper
  , lower
  , letter
  , alphaNum
  , digit
  , hexDigit
  , octDigit
  , newline
  , tab
  , space


  , lexeme

  , natural
  , integer
  , int


  ) where

import Control.Applicative
import Control.Monad
import Data.Char


import Text.ZParse.Combinators


type HString = [Char] -> [Char]

emptyH :: HString
emptyH = id

fromH :: HString -> String
fromH = ($ "")

appendH :: HString -> HString -> HString
appendH = (.)


snocH :: HString  -> Char -> HString
snocH h c = h . (c:)



--
-- Ideally we would like Continuations plus Writer, but this
-- combination makes a funny beast.
-- 
-- Ideally we would like the censoring operation:
--
-- > censorW ma = censor (const mempty) ma
--
-- ... to control how we produce output, it has exactly the 
-- interface we want to make a general replace function:
--
-- replace ma f = censorW ma >>= \a -> tell (f a) -> return a
--
-- Unfortunately censoring has unlimited extent!! With the 
-- two continuation monad, all output after the first call 
-- to censor is censored, not just the locally censored action.
-- 
-- ... So we stuff everything in a State record and have a 
-- special append that can either append or drop-right (when we
-- are in censor mode).
-- 
--


data ParserState = ParserState
      { rewrite_output  :: HString
      , rest_of_input   :: String
      }

inputEOF :: ParserState -> Bool
inputEOF inp = null (rest_of_input inp)


makeParserState :: String -> ParserState
makeParserState ss = 
    ParserState { rewrite_output  = emptyH
                , rest_of_input   = ss
                }


next1 :: ParserState -> ParserState
next1 = (\s w ss -> case ss of 
                      (c:cs) -> s { rewrite_output = w `snocH` c
                                  , rest_of_input  = cs }
                      _      -> s )
         <*> rewrite_output <*> rest_of_input


data Result ans = Fail String | Okay !ParserState ans 


type SK ans a = a -> FK ans -> ParserState -> Result ans
type FK ans   = Result ans


newtype Parser a = Parser { 
      getParser :: forall ans. SK ans a -> FK ans -> ParserState -> Result ans }


type ParseError   = String




runParser :: Parser a -> String -> Either ParseError (a,String)
runParser p ss = post $ getParser p skZero fkZero (makeParserState ss)
  where
    skZero              = \ans _fk st -> Okay st ans
    fkZero              = Fail ""
    post (Okay st a)    = Right (a, fromH $ rewrite_output st)
    post (Fail err)     = Left err

    
evalParser :: Parser a -> String -> Either ParseError String
evalParser p = fmap snd . runParser p

    

parseFromFile :: FilePath -> Parser a -> IO (Either ParseError (a,String))
parseFromFile path p = readFile path >>= return . runParser p
     


-- @return@ of Monad, @pure@ of Applicative
--
yield  :: a -> Parser a
yield a = Parser $ \sk -> sk a



instance Functor Parser where
  fmap f mf = Parser $ \sk -> getParser mf $ \a -> (sk . f) a
     


instance Applicative Parser where
  pure = yield
  (<*>) = ap

instance Alternative Parser where
  empty = failure
  (<|>) = alt
  many  = eagerMany
  some  = eagerSome

 
instance Monad Parser where
  return  = yield
  m >>= k = Parser $ \sk -> getParser m $ \a -> getParser (k a) sk
 


instance MonadPlus Parser where
  mzero = failure
  mplus = alt




-- mplus of MonadPlus, (<|>) of Applicative.
--
alt :: Parser a -> Parser a -> Parser a
alt p1 p2 = Parser $ \sk fk st -> getParser p1 sk (getParser p2 sk fk st) st



infixl 5 `apply`

apply :: Parser a -> (a -> b) -> Parser b
apply = flip fmap


failure :: Parser a
failure = Parser $ \_ fk _ -> fk



both :: Parser a -> Parser b -> Parser (a,b)
both p q = Parser $ \sk fk st@(ParserState { rewrite_output = w0 }) -> 
    getParser p (\a fk2 (ParserState out inn) ->  
        getParser q (\b -> sk (a,b)) fk2 (ParserState w0 (out $ inn)))
             fk (st { rewrite_output = emptyH})
        


-- eager-many / zero-or-more (many of Applicative)
--
eagerMany :: Parser a -> Parser [a]
eagerMany p = (p >>= \r -> eagerMany p `apply` \rs -> (r:rs)) `alt` return [] 

-- eager-some / one-or-more (some of Applicative)
--
eagerSome :: Parser a -> Parser [a]
eagerSome p = p >>= \r -> eagerMany p `apply` \rs -> (r:rs)


--------------------------------------------------------------------------------
-- Combinators


throwError :: String -> Parser a
throwError msg = Parser $ \_ _ _ -> Fail msg


infixr 0 <?>

(<?>) :: Parser a -> String -> Parser a
p <?> msg = Parser $ \sk fk st -> getParser p sk (swapMsg fk) st
  where
    swapMsg (Fail _) = Fail msg
    swapMsg okay     = okay




-- | This one is from Chris Okasaki\'s \"Even Higher-Order 
-- Functions for Parsing\".
--
lookahead :: Parser a -> (a -> Parser b) -> Parser b 
lookahead p mf  = Parser $ \sk fk -> 
    getParser p (\a fk2 -> getParser (mf a) sk fk2) fk


-- | Peek tries the supplied parse, but does not consume input 
-- \*\* even when the parse succeeds \*\*.
--
-- Doed not write ouput either.
-- 
peek :: Parser a -> Parser a
peek p = Parser $ \sk fk st -> 
    getParser p (\a fk2 _ -> sk a fk2 st) fk st





eof :: Parser ()
eof = Parser go
  where
    go sk fk st | inputEOF st = sk () fk st
    go _  fk _                = fk



char :: Char -> Parser Char
char ch = Parser go
  where
    go sk fk st = case rest_of_input st of
                    (c:_) | c == ch -> sk c fk (next1 st)
                    _               -> fk



satisfy :: (Char -> Bool) -> Parser Char
satisfy test = Parser go
  where
    go sk fk st = case rest_of_input st of
                    (c:_) | test c -> sk c fk (next1 st)
                    _              -> fk



oneOf           :: [Char] -> Parser Char
oneOf cs        = satisfy (`elem` cs)

noneOf          :: [Char] -> Parser Char
noneOf cs       = satisfy (`notElem` cs)



genReplace :: Parser a -> (a -> ShowS) -> Parser a
genReplace p f = censor p >>= \a -> tell (f a) >> return a



censor :: Parser a -> Parser a
censor p = Parser $ \sk fk st@(ParserState { rewrite_output = w0 }) -> 
    getParser p (\a fk2 st2 -> sk a fk2 (st2 { rewrite_output = w0 })) fk st


tell :: ShowS -> Parser ()
tell msg = Parser $ \sk fk st -> sk () fk (upd st)
  where
    upd = (\s w -> s { rewrite_output = w `appendH` msg }) 
            <*> rewrite_output 


replaceChar :: Char -> Char -> Parser Char
replaceChar old new = genReplace (char old) (const (new:)) 


--------------------------------------------------------------------------------
-- Char parsers


string :: String -> Parser String
string ss = mapM char ss



anyChar :: Parser Char
anyChar = Parser go
  where
   go sk fk inp@(ParserState { rest_of_input = (c:_) }) = sk c fk (next1 inp)
   go _  fk _   = fk


upper       :: Parser Char
upper       = satisfy isUpper

lower       :: Parser Char
lower       = satisfy isLower

letter      :: Parser Char
letter      = satisfy isAlpha

alphaNum    :: Parser Char
alphaNum    = satisfy isAlphaNum

digit       :: Parser Char
digit       = satisfy isDigit 

hexDigit    :: Parser Char
hexDigit    = satisfy isHexDigit

octDigit    :: Parser Char
octDigit    = satisfy isOctDigit

newline     :: Parser Char
newline     = char '\n'

tab         :: Parser Char
tab         = char '\t'

space       :: Parser Char
space       = satisfy isSpace





-- | Lexeme is quite subtle, it must definitely consume some 
-- blank input or be at the end of file.
--
-- Just doing:
--
-- > many space
--
-- Is wrong as the parser wont necesarily consume the full input.
--
lexeme      :: Parser a -> Parser a
lexeme p    = p <* (eof <|> some_spaces) 
  where
    some_spaces = many1 space >> return ()


naturalParser :: Num a => (Char -> a) -> Parser a
naturalParser conv = post 0 <$> eagerSome digit
  where
    post ac (c:cs) = post (ac * 10 + (conv c)) cs
    post ac []     = ac

signedParser :: Num a => Parser a -> Parser a
signedParser pnum = ($) <$> psign <*> pnum
  where
    psign = option id (negate <$ char '-')


natural :: Parser Integer
natural = naturalParser (fromIntegral . digitToInt)


integer :: Parser Integer
integer = signedParser natural

int     :: Parser Int
int     = signedParser (naturalParser digitToInt)

